;; This file is part of Scheme-GNUnet
;; Copyright © 2022 GNUnet e.V.
;;
;; Scheme-GNUnet is free software: you can redistribute it and/or modify it
;; under the terms of the GNU Affero General Public License as published
;; by the Free Software Foundation, either version 3 of the License,
;; or (at your option) any later version.
;;
;; Scheme-GNUnet is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
;;
;; SPDX-License-Identifier: AGPL-3.0-or-later

;; Author: Maxime Devos
(define-library (gnu gnunet concurrency lost-and-found)
  (export make-lost-and-found lost-and-found? collect-lost-and-found-operation
	  make-losable <losable> losable?
	  ;; exported for tests
	  (rename (add-found! #{ add-found!}#)))
  (import (only (rnrs base)
		begin let define lambda quote if cond eq? assert cons list)
	  (only (rnrs control)
		when unless)
	  (only (rnrs records syntactic)
		define-record-type)
	  (only (guile)
		make-guardian add-hook! after-gc-hook object-address)
	  (only (ice-9 format)
		format)
	  (only (srfi srfi-9 gnu)
		set-record-type-printer!)
	  (only (ice-9 atomic)
		make-atomic-box atomic-box-ref)
	  (only (fibers conditions)
		make-condition condition? signal-condition! wait-operation)
	  (only (fibers operations)
		wrap-operation make-base-operation)
	  ;; TODO: move elsewhere
	  (only (gnu gnunet mq envelope)
		%%bind-atomic-boxen))
  (begin
    (define-record-type (<lost-and-found> make-lost-and-found lost-and-found?)
      ;; Atomic box of [condition | (found found* ...)].
      ;; When there is nothing found, the condition is unsignalled.
      ;;
      ;; To register something lost, it is added to the list (if any),
      ;; otherwise the condition is replaced by the lost object, then
      ;; the condition is signalled.
      (fields (immutable contents-box lost-and-found-contents-box))
      (protocol (lambda (%make)
		  (lambda ()
		    (%make (make-atomic-box (make-condition)))))))

    (set-record-type-printer!
     <lost-and-found>
     (lambda (record port)
       (format port "#<lost-and-found ~x ~a>"
	       (object-address record)
	       (if (condition?
		    (atomic-box-ref (lost-and-found-contents-box record)))
		   "empty"
		   "non-empty"))))

    ;; TODO: concurrency this operation, not reusable
    (define (collect-lost-and-found-operation lost-and-found)
      "Make an operation that will complete when something lost has been
found and return the newly found objects as a list.  If this operation is
performed multiple times concurrently on the same lost and found, spurious
wakeups where the empty list is returned are possible."
      (%%bind-atomic-boxen
       ((value (lost-and-found-contents-box lost-and-found) swap!))
       (let ((old value)
	     (new-condition (make-condition)))
	 (define (loop old)
	   ;; The mutation replacing 'old' by 'value' is detected by
	   ;; the tests "new lost between making the operation and performing
	   ;; it".
	   (define new-old (swap! old new-condition))
	   ;; If a condition, a concurrent
	   ;; 'collect-lost-and-found-operation' has took the found
	   ;; objects, return a spurious empty list.
	   ;;
	   ;; The mutations ‘inverse the condition’, ‘remove this clause’,
	   ;; and ‘return new-old’ are detected by the test "concurrent
	   ;; collecting (light)".
	   ;;
	   ;; The mutation ‘replace ‘new-old’ by ‘old’ or ‘value’’ is detected
	   ;; by "new lost between making the operation and performing it (2)".
	   ;;
	   ;; TODO: detect switching the first two clauses.
	   (cond ((condition? new-old) '())
		 ;; eq? and not a condition --> succesfully replaced a
		 ;; list of found objects with 'new-condition', return
		 ;; the list.
		 ;;
		 ;; The mutations ‘remove this clause’, ‘always return the
		 ;; empty list’, ‘inverse the condition’, ‘replace new-old or
		 ;; old by value’ are detected by the test "unreachable + gc ->
		 ;; moved into lost and found".
		 ((eq? old new-old) old)
		 ;; not eq? --> a race happened, retry
		 ;;
		 ;; The mutations ‘removing this clause’,
		 ;; ‘returning the empty list’ and ‘calling loop twice’ are
		 ;; detected by tests "new lost between making the operation and
		 ;; performing it".
		 (#true (loop new-old))))
	 ;; The mutation ‘use value instead of old’ is detected ‘losing and
	 ;; collecting concurrently’ (somewhat irreproducible).
	 (if (condition? old)
	     (wrap-operation
	      ;; The mutation ‘don't wait for anything’ is detected by
	      ;; the test "block while nothing to collect".
	      ;; The mutation ‘use value instead of old’ is detected by
	      ;; the test "losing and collecting concurrently".
	      (wait-operation old)
	      ;; The mutations 'always return the empty list' and 'call loop
	      ;; twice' are detected by test "new lost between making the
	      ;; operation and performing it (2)".
	      ;;
	      ;; The mutation ‘replace old by value’ _survives_ but seems
	      ;; benign.
	      (lambda () (loop old)))
	     ;; 'collect-lost' added something before we started waiting,
	     ;; return it when asked for (unless a race interferes).
	     (make-base-operation
	      #false ; wrap
	      ;; Try (always succeeds).
	      ;; The mutations ‘always return the empty list’ and
	      ;; 'call loop twice' are rejected by test
	      ;; "unreachable + gc -> moved into lost and found".
	      ;;
	      ;; The mutation ‘replace old by value’ _survives_ but seems
	      ;; benign.
	      (lambda () (lambda () (loop old)))
	      ;; There is no block, only try -- try always succeeds.
	      "do not call me, try always returns!")))))

    (define (add-found! lost-and-found lost)
      "Add an object @var{lost} to @var{lost-and-found}."
      (%%bind-atomic-boxen
       ((value (lost-and-found-contents-box lost-and-found) swap!))
       (let loop ((old value))
	 ;; The mutations ‘simply run the first branch’, ‘simply run
	 ;; the second branch’, ‘run both branches’ and ‘invert the
	 ;; branch condition’ are detected by test "unreachable + gc ->
	 ;; moved into lost and found".
	 ;;
	 ;; TODO: maybe detect replacing ‘old’ by ‘value’.
	 (if (condition? old)
	     ;; Replace the condition by a list containing lost,
	     ;; then notify the condition.  This ordering is important,
	     ;; otherwise 'collect-lost-and-found-soperation' could
	     ;; be unnecessarily in the ‘spuriously return the empty list’
	     ;; case, even when there aren't multiple concurrent
	     ;; 'collect-lost-and-found-operation' operations.
	     ;;
	     ;; (Though in practice, this would not seem to be a problem,
	     ;; since 'collect-lost-and-found' is called in a loop anyway.)
	     (let ((new-old (swap! old (list lost))))
	       ;; The mutations ‘invert the branch condition’ and ‘do both
	       ;; branches (in order or out-of-order)’ are detected by the test
	       ;; "unreachable + gc -> moved into lost and found".
	       ;;
	       ;; The mutation ‘simply do the second branch’ is detected by
	       ;; test "new lost between making the operation and performing it
	       ;; (2)" (timeout).
	       ;;
	       ;; The mutation ‘simply do the first branch’ is dected by the
	       ;; test "losing and collecting concurrently" (not 100%
	       ;; reproducible).
	       (if (eq? new-old old)
		   ;; The mutation ‘don't do anything’ is detected by test
		   ;; "new lost between making the operation and performing it
		   ;; (2)" (by timeout).
		   (signal-condition! old)
		   ;; Race was lost, try again!
		   ;;
		   ;; The mutation ‘don't do anything’ is detected by the test
		   ;; "losing and collecting concurrently".
		   ;;
		   ;; The mutation ‘use old instead of new-old’ is detected by
		   ;; the test "losing and collecting concurrently" (infinite
		   ;; loop).
		   ;;
		   ;; The mutation ‘use value instead of new-value’ is
		   ;; _survives_ and seems benign, although possibly suboptimal
		   ;; performance-wise.
		   (loop new-old)))
	     ;; There is already a list of lost objects, extend it.
	     ;; The mutation ‘replace the first old by value’ causes
	     ;; "concurrent losing" to fail. TODO: replacing the second ‘old’
	     ;; is currently undetected.
	     (let ((new-old (swap! old (cons lost old))))
	       ;; The mutations ‘don't do anything’, ‘invert the condition’,
	       ;; ‘replace old by value in the condition’
	       ;; cause the test "concurrent losing" to fail.
	       ;;
	       ;; The mutations ‘always run’ and ‘replace new-old by value in
	       ;; the condition’ cause an infinite loop (presumambly with
	       ;; unbounded memory!). The mutation ‘run loop twice’ seems to
	       ;; cause an OOM or at least very high memory usage.
	       (unless (eq? new-old old)
		 ;; Race was lost, try again!
		 ;;
		 ;; The mutation ‘replace new-old by old’ causes "concurrent
		 ;; losing" to busy hang.  The mutation ‘replace new-old by
		 ;; value’ survives and seems benign, although perhaps
		 ;; suboptimal performance-wise.
		 (loop new-old)))))))

    (define *guard* (make-guardian))

    ;; TODO: test the 'lost-and-found=#false' case.
    (define-record-type (<losable> make-losable losable?)
      (fields (immutable lost-and-found losable-lost-and-found))
      (sealed #false)
      (protocol (lambda (%make)
 		  (lambda (lost-and-found)
 		    (let ((object (%make lost-and-found)))
		      (when lost-and-found
			(assert (lost-and-found? lost-and-found))
			(*guard* object))
 		      object)))))

    (define (collect-lost)
      (define object (*guard*))
      (when object
	(add-found! (losable-lost-and-found object) object)
	;; Absence detected by test
	;; "unreachable + gc -> moved into lost and found"
	(collect-lost)))

    (add-hook! after-gc-hook collect-lost)))
